perm filename PCROSS.PAS[PAS,SYS]2 blob sn#459959 filedate 1979-07-21 generic text, type C, neo UTF8
COMMENT ⊗   VALID 00017 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00003 00002	(*things yet to do:
C00007 00003	(*description and history*)
C00011 00004	(*valid switches*)
C00016 00005	(*global declarations*)
C00040 00006	    (*INITPROCEDURES*) (*reinitialize*) (*getcounts*) (*initialize*)
C00053 00007	    (*get←directives[*) (*SETSWITCH*) (*]*)
C00063 00008	    (*PAGE AND LINE CONTROL:*) (*HEADER*) (*NEWPAGE*)
C00065 00009	    (*BLOCK[*) (*OUTPUT PROCEDURES:*) (*ERROR*) (*WRITELINE[*) (*USEDOTS*) (*]*)
C00075 00010		(*SCANNER:*) (*INSYMBOL[*) (*READBUFFER[*) (*readline]*) (*RESWORD*) (*FINDNAME*) (*insertcall*)
C00086 00011		    (*parenthese*) (*docomment[*) (*options]*) (*skip_e_directory*)
C00095 00012	      (*] INSYMBOL*)
C00103 00013		(*PARSING OF DECLARATIONS:*) (*RECDEF[*) (*CASEDEF*) (*PARENTHESE*) (*]*)
C00108 00014		(*PARSING OF STATEMENTS:*) (*STATEMENT[*) (*AND ITS PARTS*) (*]*)
C00120 00015		(*]BLOCK*)
C00127 00016	    (*PRINT←XREF←LIST[*) (*CHECKPAGE*) (*WRITEPROCNAME*) (*WRITELINENR*) (*DUMPCALL*) (*]*)
C00137 00017	    (*MAIN PROGRAM*)
C00139 ENDMK
C⊗;
(*things yet to do:
	version 3 should not play with crosslist.
		(careful: no nested version stuff).
	version 3 → PFORM
	test #name, =name.
	get the compiler to work on =name, #name.
*)

(*$T-,r64,d-   *)		(*title page*)

(********************************************************************************
 *
 *				p c r o s s 
 *				***********
 *
 *      (C) COPYRIGHT 1978, 1979
 *              BOARD OF TRUSTEES
 *              LELAND STANFORD JUNIOR UNIVERSITY
 *              STANFORD, CA. 94305, U. S. A.
 *
 *      (C) COPYRIGHT 1978, 1979
 *              ARMANDO R. RODRIGUEZ
 *              LOTS COMPUTER FACILITY
 *              STANFORD UNIVERSITY
 *              STANFORD, CA. 94305, U. S. A.
 *
 *      (C) COPYRIGHT 1976,
 *              H.-H. NAGEL
 *              INSTITUT FUER INFORMATIK
 *              DER UNIVERSITAET HAMBURG
 *              SCHLUETERSTRASSE 70
 *              2000 HAMBURG-13
 *              GERMANY
 *
 *
 *		pcross is a mixture of a pretty-printer and a cross-referencer
 *		for source programs written in pascal. it is compatible with
 *		the lots pascal and passgo compilers. the version numbers match
 *		each other.
 *
 *	This source contains conditionally-compiled sections, supported by the
 *	/VERSION switch, as implemented in the LOTS PASCAL/PASSGO compilers.
 *	The meanings of the switch values are:
 *
 *		1: Full PCROSS at LOTS
 *		2: PCREF (No NEWSOURCE) at LOTS
 *		3: Full PCROSS at SAIL
 *		4: PCREF at SAIL
 *
 (********************************************************************************

 (*          CONTENTS           *)



(* 2*)  (*DECLARATIONS*)
(* 3*)      (*INITPROCEDURES*)
(* 4*)      (*get←directives[*) (*SETSWITCH*) (*]*)
(* 5*)      (*PAGE AND LINE CONTROL:*) (*HEADER*) (*NEWPAGE*)
(* 6*)      (*BLOCK[*) (*OUTPUT PROCEDURES:*) (*ERROR*) (*WRITELINE[*) (*USEDOTS*) (*]*)
(* 7*)          (*SCANNER:*) (*INSYMBOL[*) (*READBUFFER*) (*RESWORD*) (*FINDNAME*) (*PARENTHESE*) (*DOCOMMENT*) (*]*)
(* 8*)          (*PARSING OF DECLARATIONS:*) (*RECDEF[*) (*CASEDEF*) (*PARENTHESE*) (*]*)
(* 9*)          (*PARSING OF STATEMENTS:*) (*STATEMENT[*) (*AND ITS PARTS*) (*]*)
(*10*)          (*]BLOCK*)
(*11*)      (*PRINT←XREF←LIST[*) (*CHECKPAGE*) (*WRITEPROCNAME*) (*WRITELINENR*) (*DUMPCALL*) (*]*)
(*12*)      (*MAIN PROGRAM*)
(*description and history*)

(**********************************************************************
 *
 *
 *       PROGRAM WHICH CREATES A CROSS REFERENCE LISTING
 *       AND A NEW, REFORMATTED VERSION OF A PASCAL PROGRAM.
 *
 *       INPUT:  PASCAL SOURCE FILE.
 *       OUTPUT: NEW REFORMATTED SOURCE FILE AND
 *               CROSS-REFERENCE LISTING.
 *
 *       FROM AN ORIGINAL CROSS-REFERENCE PROCESSOR WRITTEN BY
 *       MANUEL MALL, UNIVERSITY OF HAMBURG. (1974)
 *
 *       DATE UNKNOWN. LARRY PAULSON (STANFORD).
 *                       + MAKE THE FILES OF TYPE TEXT
 *                       + NOT AS MANY FORCED NEWLINES.
 *                       + THE REPORT ON PROCEDURE CALLS WAS CANCELLED.
 *
 *       MAR-78. ARMANDO R. RODRIGUEZ (STANFORD).
 *                       + A NEW SET OF SWITCH OPTIONS.
 *                       + SOME NEW ERRORS ARE REPORTED.
 *
 *       JUL-78. ARMANDO R. RODRIGUEZ (STANFORD).
 *               + ACCEPT NON-STANDARD COMMENT CONVENTIONS. STANDARIZE THEM.
 *               + IMPROVE THE CROSS REFERENCE LISTING.
 *               + LISTING OF PROC-FUNC CALL NESTING.
 *               + REPORT THE LINE NUMBERS OF BEGIN AND END OF BODY OF PROCEDURES.
 *
 *       SEE THE PROCEDURE get←directives FOR THE AVAILABLE SWITCHES.
 *      DEC-78. ARMANDO R. RODRIGUEZ (STANFORD)
 *              + SPEED UP AND CLEANNING OF THE CODE.
 *              + FIX SMALL BUGS.
 *
 *      MAR-79. ARMANDO R. RODRIGUEZ
 *              + IMPLEMENT STATEMENT COUNTS.
 *
 *
 *	jul-79. armando r. rodriguez.
 *		+ implement a wider /version switch system
 *		+ implement the (*$#NAME,=NAME  Switches
 *		+ Create CREF, no NEWsource file.
 *		+ adapt it for the lineprinter at sail.
 *
 *          THINGS TO BE FIXED, OR DOCUMENTED:
 *                  + IF THERE ARE TWO PROCS WITH ONE NAME, IT MIXES THEM.
 *                  + IF A PROC NAME IS USED AS A VAR LATER, IT WILL BE SEEN
 *                      AS A PROC FOR CALL-NESTING.
 *                  + MAKE IT SMART ENOUGH TO AVOID CREATING STRUCTURES
 *                      THAT WON'T BE USED, WHEN CROSS IS NOT 15.
 *
 *
 (**********************************************************************)

(*valid switches*)

    (*---------------------------------------------------------------------
     !
     !  VALID SWITCHES ARE:                     BRACKETS INDICATE OPTIONAL.
     !                                          <N> STANDS FOR AN INTEGER NUMBER.
     !  (defaults in parens are at sail)        <L> STANDS FOR A LETTER.
     !
     !  SWITCH          MEANING                                         DEFAULT.
     !
     !           FILES.
     !   /[NO]NEW        WRITTING OF THE NEWSOURCE FILE                 ON
     !   /[NO]CROSS[:<N>]  WRITTING OF THE CROSSLIST FILE.              ON,15
     !                    <N> IS THE SUM OF:
     !                          1   SOURCE PROGRAM LISTING
     !                          2   LISTING OF IDENTIFIERS
     !                          4   LISTING OF PROC-FUNC
     !                              DECLARATION NESTING.
     !                          8   LISTING OF PROC-FUNC CALL NESTING.
     !   /VERSION:<N>    BEHAVE AS IF CONDITIONALLY COMPILING %<N>
     !                     COMMENTS.                                    -1
     !
     !           PAGE AND LINE FORMAT
     !	 /width:<n>	 maximum line length in crosslist		132 (120)
     !   /INDENT:<N>     INDENTATION BETWEEN LEVELS.                    4
     !   /INCREMENT:<N>  LINE NUMBER INCREMENT                          100
     !   /[NO]DOTS       PUT AS A GUIDE A DOTTED LINE AT THE LEFT
     !                   MARGIN EVERY FIFTH LINE                        ON
     !	 /lines:<n>	 number of lines per page			57  (51)
     !
     !           STATEMENT FORMAT
     !   /BEGIN:[-]<N>   IF THE [-] IS NOT THERE, THE CONTENTS OF A
     !                     BEGIN..END BLOCK IS INDENTED N SPACES FURTHER.
     !                   IF IT IS THERE, THE BLOCK WILL NOT BE INDENTED,
     !                     BUT THE BEGIN AND END STATEMENTS WILL BE
     !                     EXDENTED N SPACES.                           0
     !   /[NO]FORCE      FORCES NEWLINE IN STANDARD PLACES. (BEFORE AND
     !                    AFTER BEGIN, END, THEN, ELSE, REPEAT, ETC.)   OFF
     !
     !           UPPER AND LOWER CASE
     !                          NOTE: THE POSSIBLE VALUES FOR <L> ARE:
     !                                  U MEANS UPPER CASE
     !                                  L MEANS LOWER CASE.
     !
     !   /RES:<L>        CASE USED FOR RESERVED WORDS.                  U
     !   /NONRES:<L>     SAME FOR NON-RESERVED WORDS.                   L
     !   /COMM:<L>       SAME FOR COMMENTS.                             L (U)
     !   /STR:<L>        SAME FOR STRINGS.                              U
     !   /CASE:<L>       RESETS ALL THE DEFAULTS TO <L>.                OFF
     !
     +--------------------------------------------------------------------*)

(*global declarations*)

%13
PROGRAM pform ;
\
%24
program pcref;
\

CONST
    %1 version = 'Pform/LOTS 1.0 10-jul-79';	\
    %2 version = 'pcref/lots 1.0 10-jul-79';	\
    %3 version = 'Pform/sail 1.0 10-jul-79';	\
    %4 version = 'pcref/sail 1.0 10-jul-79';	\
    verlength = 10;
    %12 stdmaxline = 57;	\       (*MAXIMUM NUMBER OF LINES PER PAGE, IGNORING HEADER*)
    %12 maxcrossch = 132;	\
    %12 margin = 16;	\
    %12 linnumsize = 5;	\
    %3 stdmaxline = 51;	\
    %4 stdmaxline = maxint;	\
    %34 maxcrossch = 120;	\
    %34 margin = 14;	\
    %34 linnumsize = 3;	\
    countersize = 8;			 (*field size for the statement count value*)
    max←line←count = 7777B;               (*LIMIT OF LINES/EDIT-PAGE*)
    max←page←count = 77B;                 (*LIMIT OF EDIT-PAGES*)
    (*          MAX←LINE←COUNT AND MAX←PAGE←COUNT SHOULD NOT NEED MORE THAN 18 BITS TOTAL*)
    ht = 11B;				 (*ascii tab*)
    ff = 14B;                            (*ASCII FORM FEED*)
    cr = 15B;                            (*ASCII CARRIAGE RETURN*)
    blanks = '          ';               (*FOR EDITING PURPOSES*)
    %12 dots = '   .   .   .   +   .   .   .   +   .   .   .   +   .   .   .   +   .   .   .   +   .   .   .   +   .   .   .   +';	\
    %34 dots = '  .  .  .  +  .  .  .  +  .  .  .  +  .  .  .  +  .  .  .  +  .  .  .  +  .  .  .  +  .  .  .  +  .  .  .  +  .  .  .  +';	\

TYPE
    pack6 = PACKED ARRAY[1..6] OF char;
    pack9 = PACKED ARRAY[1..9] OF char;

    errkinds = (begerrinblkstr,missgend,missgthen,missgof,missgexit,
		missgrpar,missgquote,missgmain,missgpoint,linetoolong,illversion,
		missgrbrack,missguntil);
    lineptrty = ↑line;
    listptrty = ↑list;
    procstructy = ↑procstruc;
    calledty = ↑called;

    linenrty = 0..max←line←count;
    pagenrty = 0..max←page←count;

    symbol = (labelsy,constsy,typesy,varsy,programsy,             (*DECSYM*)
	      functionsy,proceduresy,initprocsy,                  (*PROSYM*)
	      endsy,untilsy,elsesy,thensy,exitsy,ofsy,dosy,eobsy, (*ENDSYMBOLS*)
	      beginsy,casesy,loopsy,repeatsy,ifsy,                (*BEGSYM*)
	      recordsy,forwardsy,gotosy,othersy,intconst,ident,strgconst,externsy,langsy,forsy,whilesy,
	      rbracket,rparent,semicolon,point,lparent,lbracket,colon,eqlsy,otherssy(*DELIMITER*));

    line = PACKED RECORD
		      (*DESCRIPTION OF THE LINE NUMBER*)
		      linenr : linenrty;            (*LINE NUMBER*)
		      pagenr : pagenrty;            (*PAGE NUMBER*)
		      contlink : lineptrty;         (*NEXT LINE NUMBER RECORD*)
		      declflag: char;               (*'D' IF DECLARATION, 'M' IF MULTIPLE OCCURRENCE,
						     BLANK OTHERWISE*)
		  END;

    list = PACKED RECORD
		      (*DESCRIPTION OF IDENTIFIERS*)
		      name : alfa;                  (*NAME OF THE IDENTIFIER*)
		      llink ,                       (*LEFT SUCCESSOR IN TREE*)
		      rlink : listptrty;            (*RIGHT SUCCESSOR IN TREE*)
		      first ,                       (*POINTER TO FIRST LINE NUMBER RECORD*)
		      last  : lineptrty;            (*POINTER TO LAST LINE NUMBER RECORD*)
		      externflag: char;             (*'E' IF EXTERNAL, 'F' IF FORWARD,
						     'D' IF TWO PROCS WITH THE SAME NAME, BLANK OTHERWISE*)
		      profunflag : char;            (*'P' IF PROCEDURE NAME, 'F' IF FUNCTION, BLANK OTHERWISE*)
		      procdata: procstructy;
		  END;


    procstruc = PACKED RECORD
			   (*DESCRIPTION OF THE PROCEDURE NESTING*)
			   procname : listptrty;    (*POINTER TO THE APPROPRIATE IDENTIFIER*)
			   nextproc : procstructy;  (*POINTER TO THE NEXT ELEMENT*)
			   linenr,                  (*LINE NUMBER OF THE PROCEDURE DEFINITION*)
			   begline,                 (*LINE NUMBER OF THE BEGIN STATEMENT*)
			   endline: linenrty;       (*LINENUMBER OF THE END STATEMENT*)
			   pagenr ,                 (*PAGE NUMBER OF THE PROCEDURE DEFINITION*)
			   begpage,                 (*PAGE NUMBER OF THE BEGIN STATEMENT*)
			   endpage,                 (*PAGE NUMBER OF THE END STATEMENT*)
			   proclevel: pagenrty;     (*NESTING DEPTH OF THE PROCEDURE*)
			   firstcall: calledty;     (*LIST OF PROCEDURES CALLED BY THIS ONE*)
			   printed: boolean;        (*TO AVOID LOOPS IN THE CALL-NEST LIST*)
		       END;

    called = PACKED RECORD
			nextcall : calledty;
			whom : procstructy;
		    END;

VAR
    (*                  (*INPUT CONTROL*)
    (*                  (***************)

    bufflen,                              (*LENGTH OF THE CURRENT LINE IN THE INPUT BUFFER*)
    buffmark,                             (*LENGTH OF THE ALREADY PRINTED PART OF THE BUFFER*)
    bufferptr,                            (*POINTER TO THE NEXT CHARACTER IN THE BUFFER*)
    syleng,                               (*LENGTH OF THE LAST READ IDENTIFIER OR LABEL*)

    (*                  (*NESTING AND MATCHING CONTROL*)
    (*                  (******************************)

    bmarknr,                              (*NUMBER FOR MARKING OF 'BEGIN', 'LOOP' ETC.*)
    emarknr,                              (*NUMBER FOR MARKING OF 'END', 'UNTIL' ETC.*)
    level,                                (*NESTING DEPTH OF THE CURRENT PROCEDURE*)
    variant←level,                        (*NESTING DEPTH OF VARIANTS*)
    blocknr,                              (*COUNTS THE STATEMENTS 'BEGIN', 'CASE', 'LOOP', 'REPEAT', 'IF'*)
    errcount,                              (*COUNTS THE ERRORS ENCOUNTERED*)

    (*                  (*FORMATTING*)
    (*                  (************)

    increment,                            (*LINE NUMBER INCREMENT*)
    indentbegin,                          (*INDENTATION AFTER A BEGIN*)
    begexd,                               (*EXDENTATION FOR BEGIN-END PAIRS*)
    feed,                                 (*INDENTATION BY PROCEDURES AND BLOCKS*)
    spaces,                               (*INDENTATION FOR THE CURRENT LINE*)
    lastspaces,                           (*ONE-TIME OVERRIDING VALUE FOR SPACES*)
    goodversion,                          (*KEEPS THE VALUE OF THE VERSION OPTION*)
    countline,                            (*NEXT LINE FOR STATEMENT COUNTER*)
    countpage,                            (*PAGE OF NEXT LINE FOR STATEMENT COUNTER*)
    counttimes,                           (*STATEMENT COUNT OF COUNTLINE/COUNTPAGE*)
    maxcounttimes,                        (*COUNT OF THE LINE WITH HIGHER COUNTTIMES*)
    maxcountline,                         (*LINE FOR MAXCOUNTTIMES*)
    maxcountpage,                         (*PAGE FOR MAXCOUNTTIMES*)
    pagecnt,                              (*COUNTS THE FILE PAGES*)
    pagecnt2,                             (*COUNTS THE PRINT PAGES PER FILE PAGE*)
    maxinc,                               (*GREATEST ALLOWABLE LINE NUMBER*)
    maxline,				  (*number of lines per page*)
    maxch,				  (*maximum length of source line in CROSSLIST*)
    reallincnt,                           (*COUNTS THE LINES  PER PRINT PAGE*)
    line500,				  (*to give a tty message every 500 lines*)
    sourceline,				  (*to match SOS lines*)
    sourcepage,
    linecnt : integer;                    (*COUNTS THE LINES  PER FILE PAGE*)

    procstrucdata : RECORD
			(*NEXT PROCEDURE TO BE PUT IN NESTING LIST*)
			exists : boolean;
			item : procstruc;
		    END;

    lower : ARRAY [ascii] OF ascii;       (*TO MAP UPPER TO LOWER CASE IF DESIRED*)
    buffer  : ARRAY [-1..302] OF ascii;   (*INPUT BUFFER*)
    (*          BUFFER HAS 2 EXTRA POSITIONS ON THE LEFT AND ONE ON THE RIGHT*)

    tabs: ARRAY [1:17] OF ascii;          (*A STRING OF TABS FOR FORMATTING*)

    linenb : PACKED ARRAY [1..5] OF char; (*SOS-LINE NUMBER*)
    date←text,time←text: alfa;            (*HEADING DATE AND TIME*)
    curprocname,                           (*NAME OF THE CURRENT PROCEDURE/FUNCTION, FOR THE HEADER*)
    prog←name,                            (*NAME OF CURRENT PROGRAM*)
    sy      : alfa;                       (*LAST SYMBOL READ*)
    syty    : symbol;                     (*TYPE OF THE LAST SYMBOL READ*)
    marksyty,				  (*type of the symbol before the last if*)
    prevsyty: symbol;			  (*type of the previous symbol*)

    (*			(*version system*)
    (*			(****************)

    incondcomp: boolean;
    whichcond: char;
    nameversion: packed array[1..5] of char;

    (*                  (*SWITCHES*)
    (*                  (**********)

    %13 renewing,	\                 (*SET IF THE NEWLSOURCE FILE IS BEING WRITTEN*)
    crossing,                             (*SET IF THE CROSSLIST FILE IS BEING WRITEN*)
    refing,                               (*SET IF THE REFERENCES WILL BE PRINTED*)
    decnesting,                           (*SET IF THE PRO-FUNC DECLARATION LISTING WILL BE PRINTED*)
    callnesting,                          (*SET IF THE PRO-FUNC CALL NESTING WILL BE PRINTED*)
    dotting,                              (*SET IF DOTED LINES WILL BE PRINTED AT LEFT MARGIN*)
    forcing,                              (*SET IF THEN, ELSE, DO, REPEAT WILL FORCE NEWLINE*)
    rescase,                              (*SET IF RESERVED WORDS WILL UPSHIFT*)
    nonrcase,                             (*SET IF NONRESERVED WORDS WILL UPSHIFT*)
    comcase,                              (*SET IF COMMENTS WILL UPSHIFT*)
    strcase,                              (*SET IF STRINGS WILL UPSHIFT*)
    thendo,                               (*SET WHENEVER 'SPACES := SPACES+DOFEED' IS EXECUTED*)
    anyversion,                           (*SET IF GOODVERSION > 9*)
    counting,                             (*SET IF A .KNT EXISTS, FOR STATEMENT COUNTS*)

    (*                  (*OTHER CONTROLS*)
    (*                  (****************)

    elsehere,				  (*set when counting, forcing, and an else is here*)
    fwddecl,                              (*SET TRUE BY BLOCK AFTER 'FORWARD', 'EXTERN'*)
    oldspaces,                            (*SET WHEN LASTSPACES SHOULD BE USED*)
    eoline,                               (*SET AT END ON INPUT LINE*)
    gotoinline,                           (*SET IF A HORRENDOUS GOTO STATEMENT IN THIS LINE*)
    declaring,                            (*SET WHILE PARSING DECLARATIONS*)
    firstpage,                            (*TRUE BEFORE WRITTING ANYTHING*)
    %34 skipping,			  (*true while skipping the e-directory*)	\
    programpresent,                       (*SET AFTER PROGRAM ENCOUNTERED*)
    nobody,                               (*SET IF NO MAIN BODY IS FOUND*)
    stmtpart,				  (*set if processing the statement part*)
    eob     : boolean;                    (*EOF-FLAG*)
    errmsg : PACKED ARRAY[errkinds,1..40] OF char;      (*ERROR MESSAGES*)
    ch : ascii;                           (*LAST READ CHARACTER*)
    bmarktext,                            (*CHARACTER FOR MARKING OF 'BEGIN' ETC.*)
    emarktext: char;                      (*CHARACTER FOR MARKING OF 'END' ETC.*)

    (*                  (*SETS*)
    (*                  (******)

    delsy : ARRAY [' '..'←'] OF symbol;   (*TYPE ARRAY FOR DELIMITER CHARACTERS*)
    resnum: ARRAY['A'..'['] OF integer;   (*INDEX OF THE FIRST KEYWORD BEGINNING WITH THE INDEXED LETTER*)
    reslist : ARRAY [1..46] OF alfa;      (*LIST OF THE RESERVED WORDS*)
    ressy   : ARRAY [1..46] OF symbol;    (*TYPE ARRAY OF THE RESERVED WORDS*)
    alphanum,                             (*CHARACTERS FROM 0..9 AND A..Z*)
    digits : SET OF char;                 (*CHARACTERS FROM 0..9*)
    openblocksym,			  (*symbols after which a basic block starts*)
    relevantsym,                          (*START SYMBOLS FOR STATEMENTS AND PROCEDURES*)
    prosym,                               (*ALL SYMBOLS WHICH BEGIN A PROCEDURE*)
    decsym,                               (*ALL SYMBOLS WHICH BEGIN DECLARATIONS*)
    begsym,                               (*ALL SYMBOLS WHICH BEGIN COMPOUND STATEMENTS*)
    endsym  : SET OF symbol;              (*ALL SYMBOLS WHICH TERMINATE  STATEMENTS OR PROCEDURES*)
    

    (*                  (*POINTERS AND FILES*)
    (*                  (********************)

    listptr, heapmark : listptrty;        (*POINTER INTO THE BINARY TREE OF THE IDENTIFIER*)
    firstname : ARRAY ['A'..'Z'] OF listptrty;    (*POINTER TO THE ROOTS OF THE TREE*)
    procstrucf,                           (*POINTER TO THE FIRST ELEMENT OF THE PROCEDURE CALLS LIST*)
    procstrucl : procstructy;             (*POINTER TO THE LAST ELEMENT OF THE PROCEDURE CALLS LIST*)
    workcall: calledty;
    %13 new←name,	\
    countfilename,                        (*NAME OF THE STATEMENT COOUNTS FILE*)
    link←name,
    old←name, cross←name: pack9;          (*USED TO GET THE PARAMETER FILES*)
    %13 new←dev,	\
    old←dev,link←device,cross←dev:pack6;
    %13 new←prot,new←ppn,	\
    old←prot,old←ppn,cross←prot,cross←ppn: integer;
    %13 newfileid,	\
    programname,oldfileid,crossfileid: alfa;
    %13 newsource,	\
    oldsource,crosslist: text;  	  (*FILES PROCESSED BY THIS PROGRAM*)
    countfile: FILE OF integer;                   (*FILE FOR STATEMENT COUNTS*)

    (*INITPROCEDURES*) (*reinitialize*) (*getcounts*) (*initialize*)

INITPROCEDURE;
    BEGIN (*CONSTANTS*)
    eob := false;
    %12 increment:=100;	\
    %12 feed:=4;	\
    %34 increment := 1;	\
    %34 feed := 3;	\
    indentbegin:=0;
    begexd:=0;
    goodversion := -1;
    rescase:=true;
    nonrcase:=false;
    %12 comcase:=false;	\
    %34 comcase := true;	\
    strcase:=true;
    %13 renewing:=true;	\
    crossing:=true;
    refing:=false;
    decnesting:=false;
    callnesting:=false;
    dotting:=true;
    nobody := false;
    anyversion := false;
    %13 new←name:='         ';	\
    cross←name:='         ';
    %13 programname:='Pform     ';	\
    %24 programname := 'pcref     ';	\
    oldfileid:='OLDSOURCE ';
    %13 newfileid:='NEWSOURCE ';	\
    crossfileid:='CROSSLIST ';
    END (*CONSTANTS*);


INITPROCEDURE;
    BEGIN (*RESERVED WORDS*)
    resnum['A'] :=  1;    resnum['B'] :=  3;    resnum['C'] :=  4;
    resnum['D'] :=  6;    resnum['E'] :=  9;    resnum['F'] := 13;
    resnum['G'] := 18;    resnum['H'] := 19;    resnum['I'] := 19;
    resnum['J'] := 22;    resnum['K'] := 22;    resnum['L'] := 22;
    resnum['M'] := 24;    resnum['N'] := 25;    resnum['O'] := 27;
    resnum['P'] := 30;    resnum['Q'] := 33;    resnum['R'] := 33;
    resnum['S'] := 35;    resnum['T'] := 36;    resnum['U'] := 39;
    resnum['V'] := 40;    resnum['W'] := 41;    resnum['X'] := 43;
    resnum['Y'] := 43;    resnum['Z'] := 43;    resnum['['] := 43;

    reslist[ 1] :='AND       '; ressy [ 1] := othersy;
    reslist[ 2] :='ARRAY     '; ressy [ 2] := othersy;
    reslist[ 3] :='BEGIN     '; ressy [ 3] := beginsy;
    reslist[ 4] :='CASE      '; ressy [ 4] := casesy;
    reslist[ 5] :='CONST     '; ressy [ 5] := constsy;
    reslist[ 6] :='DO        '; ressy [ 6] := dosy;
    reslist[ 7] :='DIV       '; ressy [ 7] := othersy;
    reslist[ 8] :='DOWNTO    '; ressy [ 8] := othersy;
    reslist[ 9] :='END       '; ressy [ 9] := endsy;
    reslist[10] :='ELSE      '; ressy [10] := elsesy;

    reslist[11] :='EXIT      '; ressy [11] := exitsy;
    reslist[12] :='EXTERN    '; ressy [12] := externsy;
    reslist[13] :='FOR       '; ressy [13] := forsy;
    reslist[14] :='FILE      '; ressy [14] := othersy;
    reslist[15] :='FORWARD   '; ressy [15] := forwardsy;
    reslist[16] :='FUNCTION  '; ressy [16] := functionsy;
    reslist[17] :='FORTRAN   '; ressy [17] := externsy;
    reslist[18] :='GOTO      '; ressy [18] := gotosy;
    reslist[19] :='IF        '; ressy [19] := ifsy;
    reslist[20] :='IN        '; ressy [20] := othersy;

    reslist[21] :='INITPROCED'; ressy [21] := initprocsy;
    reslist[22] :='LOOP      '; ressy [22] := loopsy;
    reslist[23] :='LABEL     '; ressy [23] := labelsy;
    reslist[24] :='MOD       '; ressy [24] := othersy;
    reslist[25] :='NOT       '; ressy [25] := othersy;
    reslist[26] :='NIL       '; ressy [26] := othersy;
    reslist[27] :='OR        '; ressy [27] := othersy;
    reslist[28] :='OF        '; ressy [28] := ofsy;
    reslist[29] :='OTHERS    '; ressy [29] := otherssy;
    reslist[30] :='PACKED    '; ressy [30] := othersy;

    reslist[31] :='PROCEDURE '; ressy [31] := proceduresy;
    reslist[32] :='PROGRAM   '; ressy [32] := programsy;
    reslist[33] :='RECORD    '; ressy [33] := recordsy;
    reslist[34] :='REPEAT    '; ressy [34] := repeatsy;
    reslist[35] :='SET       '; ressy [35] := othersy;
    reslist[36] :='THEN      '; ressy [36] := thensy;
    reslist[37] :='TO        '; ressy [37] := othersy;
    reslist[38] :='TYPE      '; ressy [38] := typesy;
    reslist[39] :='UNTIL     '; ressy [39] := untilsy;
    reslist[40] :='VAR       '; ressy [40] := varsy;

    reslist[41] :='WHILE     '; ressy [41] := whilesy;
    reslist[42] :='WITH      '; ressy [42] := othersy;
    END (*RESERVED WORDS*);


INITPROCEDURE;
    BEGIN (*SETS*)
    digits := ['0'..'9'];
    alphanum := ['0'..'9','A'..'Z'] (*LETTERS OR DIGITS*);
    decsym := [labelsy,constsy,typesy,varsy,programsy];
    prosym := [functionsy..initprocsy];
    endsym := [functionsy..eobsy];      (*PROSYM OR ENDSYMBOLS*)
    begsym := [beginsy..ifsy];
    relevantsym := [labelsy..initprocsy (*DECSYM OR PROSYM*),beginsy,forwardsy,externsy,eobsy];
    openblocksym := [thensy,elsesy,dosy,loopsy,repeatsy,intconst,colon,exitsy]
    END (*SETS*);


INITPROCEDURE;
    BEGIN (*ERROR MESSAGES*)
    errmsg[begerrinblkstr] := 'ERROR IN BLOCK STRUCTURE: BEGIN EXPECTED';
    errmsg[missgend      ] := 'MISSING   ''END''  statement       NUMBER ';
    errmsg[missgthen     ] := 'MISSING   ''THEN''   FOR   ''IF''    NUMBER ';
    errmsg[missgof       ] := 'MISSING    ''OF''   IN    ''CASE''   NUMBER ';
    errmsg[missgexit     ] := 'MISSING   ''EXIT''   IN   ''LOOP''   NUMBER ';
    errmsg[missgrpar     ] := 'MISSING RIGHT PARENTHESIS               ';
    errmsg[missgquote    ] := 'MISSING CLOSING QUOTE ON THIS LINE      ';
    errmsg[missgmain     ] := 'WARNING: THIS FILE HAS NO MAIN BODY     ';
    errmsg[missgpoint    ] := 'MISSING CLOSING POINT AT END OF PROGRAM.';
    errmsg[linetoolong   ] := 'line too long. i''m gonna get confused.  ';
    errmsg[illversion    ] := 'error in name-version option (# or =)   ';
    errmsg[missguntil    ] := 'missing  ''until''  for  ''repeat''  number ';
    errmsg[missgrbrack   ] := 'missing right bracket                   ';
    END (*ERROR MESSAGES*);


PROCEDURE reinitialize;
    var
	lch: char;
    BEGIN (*REINITIALIZE*)
    new(heapmark);    (*THE HEAP IS DEALLOCATED AFTER EACH PROGRAM*)
    workcall := NIL;

    bufflen := 0;		buffmark := 0;
    bufferptr := 2;		variant←level := 0;		reallincnt:= maxline;
    line500 := 0;		linecnt :=0;			pagecnt := 1;
    pagecnt2 := 0;		sourcepage := 1;		sourceline := 0;
    maxcountpage := 0;		maxcountline := 0;		maxcounttimes := 0;
    blocknr := 0;		level := 0;			errcount := 0;

    eoline := true;		gotoinline := false;		firstpage := true;
    programpresent := false;	procstrucdata.exists := false;	oldspaces := false;
    declaring := true;		incondcomp := false;		elsehere := false;
    %skipping := false;	\

    bmarktext := ' ';		emarktext := ' ';		ch := ' ';
    whichcond := ' ';

    sy := blanks;		prog←name := blanks;

    date(date←text);  time(time←text);

    FOR lch := 'A' TO 'Z' DO
	firstname [lch] := NIL;
    new (firstname['M']);
    listptr := firstname ['M'];
    WITH firstname ['M']↑ DO
	BEGIN
	name := 'MAIN PROGM';
	llink := NIL;
	rlink := NIL;
	profunflag := 'M';
	new (first);
	last := first;
	WITH last↑ DO
	    BEGIN
	    linenr := 1;
	    pagenr:=1;
	    contlink := NIL;
	    END;
	END;
    new (procstrucf);
    WITH procstrucf↑ DO
	BEGIN
	procname := firstname ['M'];
	nextproc := NIL;
	linenr   := 1;
	pagenr:=1;
	proclevel:= 0;
	firstcall := NIL;
	END;
    procstrucl := procstrucf;
    curprocname := 'MAIN PROGM';
    END (*REINITIALIZE*);

PROCEDURE getcounts;
    BEGIN
    IF eof(countfile) THEN
	BEGIN
	countline := 99999;
	countpage := 99999;
	END
    ELSE
	BEGIN
	countpage := countfile↑;
	get(countfile);
	countline := countfile↑;
	get(countfile);
	counttimes := countfile↑;
	get(countfile);
	END;
    END (*GETCOUNTS*);

PROCEDURE initialize;
    var
	i: integer;
    BEGIN (*INITIALIZE*)
    FOR ch := ' ' TO '←' DO
	delsy [ch] := othersy;
    delsy ['('] := lparent;
    delsy [')'] := rparent;
    delsy ['['] := lbracket;
    delsy [']'] := rbracket;
    delsy [';'] := semicolon;
    delsy ['.'] := point;
    delsy [':'] := colon;
    delsy ['='] := eqlsy;
    FOR i := -1 TO 201 DO
	buffer [i] := ' ';
    FOR i := 1 TO 17 DO
	tabs [i] := chr (ht);
    FOR ch := nul TO '@' DO
	lower[ch] := ch;
    FOR ch := 'A' TO 'Z' DO
	lower[ch] := chr (ord(ch) + 40B);
    FOR ch := '[' TO del DO
	lower[ch] := ch;
    reinitialize;
    END (*INITIALIZE*);
    (*get←directives[*) (*SETSWITCH*) (*]*)

PROCEDURE get←directives;
     (* CHECKS THE PRESENCE OF SWITCHES WITH THE FILE NAMES.	*)
    VAR
	brkchar: char;
	try: integer;
	fromtmp: boolean;

    PROCEDURE setswitch(opt:alfa;VAR switch:boolean);
	VAR
	    i: integer;
	BEGIN (*SETSWITCH*)
	getoption(opt,i);
	IF i=ord('L') THEN
	    switch:=false
	ELSE
	    IF i=ord('U') THEN
		switch:=true;
	END (*SETSWITCH*);

    BEGIN (*get←directives*)

	%12
    getparameter(oldsource,oldfileid,programname,true);
	\
	%34
    askfilename(old_name,old_prot,old_ppn,old_dev,oldfileid,programname,false,fromtmp,brkchar);
    startfile(oldsource,old_name,old_prot,old_ppn,old_dev,true,oldfileid,'pas');
	\
    getstatus(oldsource,old←name,old←prot,old←ppn,old←dev);
	countfilename := old←name;
	countfilename[7] := 'K';
	countfilename[8] := 'N';
	countfilename[9] := 'T';
	reset(countfile,countfilename);
	IF eof(countfile) THEN
	    reset (countfile,countfilename,old←prot,old←ppn,old←dev);
	counting := NOT eof(countfile);
	IF counting THEN
	    begin
	    forcing := true;
	    %13 renewing := false;	\
		%4
		callnesting := false;
		decnesting := false;
		refing := false;
		\
	    getcounts;
	    end;
	%13
    IF NOT option ('NONEW     ') THEN
	askfilename(new←name,new←prot,new←ppn,new←dev,newfileid,programname,false,fromtmp,brkchar);
	\
    IF NOT option ('NOCROSS   ') THEN
	askfilename(cross←name,cross←prot,cross←ppn,cross←dev,crossfileid,programname,false,fromtmp,brkchar);

	%13
    IF renewing and NOT option ('NONEW     ') THEN
	BEGIN
	IF (new←name = '         ') AND (new←dev = 'DSK   ') THEN
	    BEGIN
	    getstatus(oldsource, new←name,old←prot,old←ppn,old←dev);
	    new←name[7]:='N';
	    new←name[8]:='E';
	    new←name[9]:='W';
	    END;
	startfile(newsource,new←name,new←prot,new←ppn,new←dev,false,newfileid,'   ');
	END;
	\

    IF NOT option('NOCROSS   ') THEN
	BEGIN
	IF (cross←name = '         ') AND (cross←dev = 'DSK   ') THEN
	    BEGIN
	    getstatus(oldsource, cross←name,old←prot,old←ppn,old←dev);
	    cross←name[7]:='l';
	    cross←name[8]:='s';
	    cross←name[9]:='t';
	    END;
	startfile(crosslist,cross←name,cross←prot,cross←ppn,cross←dev,false,crossfileid,'   ');
	END;

	%24
	IF counting THEN
	    begin
	    writeln(tty);
	    writeln(tty,'i found ',countfilename:6,'.knt: will do statement counts');
	    end
	else (*not counting*)
	    writeln(tty,countfilename:6,'.knt not found. normal cref');
	break(tty);
	\

    getstatus(oldsource,old←name,old←prot,old←ppn,old←dev);

    %13 renewing:= renewing and NOT option('NONEW     ');	\

    crossing:= NOT option('NOCROSS   ');

    counting := counting and crossing;

    IF crossing %4 and not counting  \THEN
	BEGIN
	getoption('CROSS     ',try);
	IF try = 0 THEN
	    try:=15;
	callnesting:=try > 7;
	decnesting:=(try MOD 8) > 3;
	refing:= (try MOD 4) > 1;
	crossing:=(try MOD 2) = 1;
	END;

    IF option ('VERSION   ') THEN
	BEGIN
	getoption ('VERSION   ',goodversion);
	IF goodversion > 9 THEN
	    BEGIN
	    goodversion := -1;
	    anyversion := true;
	    END;
	END;

    if option('width     ') then
	getoption('width     ',maxch)
    else
	maxch := maxcrossch;
    maxch := maxch - margin;

    IF option('INDENT    ') THEN
	BEGIN
	getoption('INDENT    ',feed);
	IF feed < 0 THEN
	    feed:=4;
	END;

    IF option('INCREMENT ') THEN
	BEGIN
	getoption('INCREMENT ',increment);
	IF increment < 0 THEN
	    increment:= 100;
	END;

    dotting:=NOT option('NODOTS    ');

    IF option('BEGIN     ') THEN
	BEGIN
	getoption('BEGIN     ',indentbegin);
	IF indentbegin < 0 THEN
	    BEGIN
	    begexd:=-indentbegin;
	    indentbegin:=0;
	    END;
	END;

    if option('lines     ') then
	getoption('lines     ',maxline)
    else
	maxline := stdmaxline;

    forcing:=forcing or option('FORCE     ');

    IF option('CASE      ') THEN
	BEGIN
	setswitch('CASE      ',rescase);
	nonrcase:=rescase;
	comcase:=rescase;
	strcase:=rescase;
	END;

    setswitch('RES       ',rescase);
    setswitch('NONRES    ',nonrcase);
    setswitch('COMM      ',comcase);
    setswitch('STR       ',strcase);
    END (*get←directives*);
    (*PAGE AND LINE CONTROL:*) (*HEADER*) (*NEWPAGE*)

PROCEDURE header (name: alfa);
    (*PRINT TOP OF FORM AND HEADER ON LIST OUTPUT*)
    BEGIN (*HEADER*)
    pagecnt2 := pagecnt2 + 1;
    reallincnt := 0;
    IF crossing THEN
	BEGIN
	IF firstpage THEN
	    firstpage := false
	ELSE
	    page(crosslist);
	%12
	write(crosslist,version:28,' ':10,old←name:6,'.',old←name[7],old←name[8],old←name[9],
	      ' [ ',prog←name,' ]',' ':9, date←text, '  ', time←text);
	writeln (crosslist, 'PAGE ':15, pagecnt:3, '-', pagecnt2:2, name:15);
	\
	%3
	write(crosslist,version:26,' ':7,old←name:6,'.',old←name[7],old←name[8],old←name[9],
	      ' [ ',prog←name,' ]      ', date←text, '  ', time←text);
	writeln (crosslist, 'PAGE ':13, pagecnt:3, '-', pagecnt2:2, name:15);
	\
	%123 writeln(crosslist);	\
	END;
    END (*HEADER*);


PROCEDURE newpage;
    BEGIN (*NEWPAGE*)
    pagecnt2 := 0;
    pagecnt := pagecnt + 1;
	%13
    IF renewing THEN
	if not firstpage then
	page(newsource);
	\
    header (curprocname);
    IF eoln (oldsource) THEN
	readln(oldsource);
			linecnt := 0;
			line500 := 0;
    IF prog←name <> blanks  THEN
	write(tty,pagecnt:3,'..');
    break(tty);
    END (*NEWPAGE*);

    (*BLOCK[*) (*OUTPUT PROCEDURES:*) (*ERROR*) (*WRITELINE[*) (*USEDOTS*) (*]*)


PROCEDURE block;
    VAR
	i: integer;
	curproc : listptrty;        (*ZEIGER AUF DIE PROZEDUR IN DEREN ANWEISUNGSTEIL DAS PROGRAMM SICH BEFINDET*)
	itisaproc : boolean;        (*TRUE WHEN THE WORD PROCEDURE IS FOUND*)
	locprocstl: procstructy;
	lastprocname: alfa;         (*IMPLICIT STACK OF PROCEDURE NAMES FOR THE HEADER*)


    PROCEDURE error (errnr : errkinds);
	BEGIN (*ERROR*)
	errcount := errcount+1;
	IF crossing THEN
	    BEGIN
	    reallincnt := reallincnt + 1; (*COUNT THE LINE FOR THE ERROR MESSAGE ON CROSSLIST*)
	    write (crosslist, ' ':17,' *??* ');
	    CASE errnr OF
		begerrinblkstr: write(crosslist, sy, errmsg[begerrinblkstr]);
		missgend,  missgthen, missguntil,
		missgexit     : write(crosslist, errmsg[errnr],emarknr : 4);
		others	      : write(crosslist, errmsg[errnr]);
		END;
	    writeln(crosslist,' *??*');
	    END;
	writeln(tty);
	write (tty, 'ERROR AT ', linecnt*increment: linnumsize, '/', pagecnt:2,': ');
	CASE errnr OF
	    begerrinblkstr: write(tty, sy, errmsg[begerrinblkstr]);
	    missgend,  missgthen, missguntil,
	    missgexit     : write(tty, errmsg[errnr],emarknr : 4);
	    others	  : write(tty, errmsg[errnr]);
	    END;
	writeln(tty);
	break (tty);
	END (*ERROR*) ;


    PROCEDURE writeline (position (*LETZTES ZU DRUCKENDES ZEICHEN IM PUFFER*): integer);
	VAR
	    i, j, maxchar: integer;    (*MARKIERT ERSTES ZU DRUCKENDES ZEICHEN*)


	PROCEDURE usedots(lastspaces: integer);

	    BEGIN (*USEDOTS*)
	    (*USE EITHER DOTS OR SPACES TO MAKE INDENTATION*)
	    IF lastspaces >= 0 THEN
		IF dotting AND ((reallincnt MOD 5) = 0) THEN
		    write(crosslist,dots: lastspaces)
		ELSE  (*no dots in this line*)
		    BEGIN
		    lastspaces := lastspaces;
		    if lastspaces > 7 then
			lastspaces := lastspaces + 2 + linnumsize;
		    write(crosslist, tabs: lastspaces DIV 8, ' ': lastspaces MOD 8);
		    END;
	    IF counting THEN	(*if making statement counts, print the count*)
		BEGIN
		WHILE (sourcepage > countpage) DO	(*find the count for this line*)
		    getcounts;
		IF sourcepage = countpage THEN
		    WHILE sourceline > countline DO
			getcounts;
		IF (countline = sourceline) AND (countpage = sourcepage) and
			not elsehere then
		    BEGIN				(*if it exists, print it*)
		    write(crosslist,counttimes:countersize,'-+      ');
		    IF counttimes >= maxcounttimes THEN
			BEGIN
			maxcounttimes := counttimes;
			maxcountline := sourceline;
			maxcountpage := sourcepage;
			END;
		    getcounts;
		    END
		ELSE	(*no count here*)		(*otherwise, fill the space*)
		    IF dotting AND ((reallincnt MOD 5) = 0) THEN
			if stmtpart then
			write(crosslist,dots:countersize+1,'!      ')
			else
			    write(crosslist,dots:countersize+7,' ')
		    ELSE
			if stmtpart then
			write(crosslist,'!':countersize+2,' ':6)
			else
			    write(crosslist,' ':countersize+8);
		END  (*counting*)
	    else  (*not counting*)
		write(crosslist,' ');
	    END (*USEDOTS*);

	BEGIN (*WRITELINE*)
	position := position - 2;
	IF position > 0 THEN
	    BEGIN
	    i := buffmark + 1;                                  (* 1. DISCARD BLANKS AT BOTH ENDS *)
	    WHILE (buffer [i] = ' ') AND (i <= position) DO
		i := i + 1;
	    buffmark := position;
	    WHILE (buffer [position] = ' ') AND (i < position) DO
		position := position - 1;

	    IF i <= position THEN                               (* 2. IF ANYTHING LEFT, WRITE IT. *)
		BEGIN
		IF NOT oldspaces THEN
		    lastspaces := spaces;

		IF crossing THEN                                (* 2.1. WRITE THE LINE IN CROSSLIST *)
		    BEGIN
		    IF reallincnt >= maxline THEN
			header (curprocname);
		    reallincnt := reallincnt + 1;

		    IF gotoinline THEN                          (* 2.1.1. LEFT MARGIN *)
			BEGIN
			write(crosslist, '***GOTO***');
			gotoinline := false;
			bmarktext:=' ';
			emarktext:=' ';
			END
		    ELSE
			BEGIN
			IF bmarktext <> ' ' THEN
			    BEGIN
			    write (crosslist, bmarktext, bmarknr : 3, ' ');
			    bmarktext := ' ';
			    END
			ELSE
			    write(crosslist,'     ');
			IF emarktext <> ' ' THEN
			    BEGIN
			    write (crosslist,emarktext,emarknr : 3,' ');
			    emarktext := ' ';
			    END
			ELSE
			    write (crosslist,'     ');
			END;

		    write (crosslist, linecnt * increment : linnumsize);     (* 2.1.2. LINENUMBER AND INDENTATION *)
		    usedots(lastspaces);
		    maxchar:=maxch+i-lastspaces-1;
		    IF counting THEN
			maxchar := maxchar - countersize+7;

		    FOR j := i TO position DO                   (* 2.1.3. CONTENTS OF THE LINE *)
			BEGIN
			IF j > maxchar THEN
			    BEGIN
			    writeln(crosslist);
			    IF reallincnt = maxline THEN
				header (blanks);
			    reallincnt:=reallincnt+1;
			    write(crosslist,' ':margin);
			    usedots(spaces+feed-1);
			    maxchar:=maxch+j-lastspaces-1;
			    END;
			crosslist↑ := buffer[j];
			put(crosslist);
			END;
		    writeln(crosslist);
		    END;

		%13
		IF renewing THEN                                (* 2.2. WRITE THE LINE IN NEWSOURCE *)
		    BEGIN
		    write (newsource, tabs:lastspaces DIV 8, ' ':lastspaces MOD 8);
		    FOR j := i TO position DO
			BEGIN
			newsource↑ := buffer[j];
			put(newsource);
			END;
		    writeln(newsource);
		    END;
		\

		WHILE (buffmark < bufflen) AND (buffer[buffmark] = ' ') DO      (* 3. RESET POINTERS AND FLAGS *)
		    buffmark := buffmark + 1;
		IF buffmark < bufflen THEN
		    IF buffer[buffmark - 1] = ' ' THEN
			buffmark := buffmark - 1
		    ELSE
		ELSE
		    IF (linenb = '     ') THEN
			BEGIN
			newpage;
			sourcepage := sourcepage + 1;
			sourceline := 0;
			END
		    ELSE
			IF (linecnt >= maxinc) THEN
			    newpage;

		END  (* IF I <= POSITION *);
	    END  (* IF POSITION > 0 *);
	lastspaces := spaces;
	oldspaces := false;
	thendo := false;
	END (*WRITELINE*) ;
	(*SCANNER:*) (*INSYMBOL[*) (*READBUFFER[*) (*readline]*) (*RESWORD*) (*FINDNAME*) (*insertcall*)

    PROCEDURE insymbol ;
	LABEL
	    1,111;
	VAR
	    oldspacesmark,            (*ALTER ZEICHENVORSCHUB BEI FORMATIERUNG VON KOMMENTAREN*)
	    i: integer;
	incondcomp: boolean;



	PROCEDURE readbuffer;
	    (*READS A CHARACTER FROM THE INPUT BUFFER*)


	    PROCEDURE readline;
		(*HANDLES LEADING BLANKS AND BLANK LINES, READS NEXT NONBLANK LINE
		 (WITHOUT LEADING BLANKS) INTO BUFFER*)
		VAR
		    ch : char;
		    i: integer;
		BEGIN (*READLINE*)
		(*ENTERED AT THE BEGINNING OF A LINE*)
		LOOP
		    WHILE eoln (oldsource) AND NOT eof (oldsource) DO
			BEGIN
			(*IS THIS A PAGE MARK?*)
			getlinenr (oldsource,linenb);
			readln(oldsource);
			IF linenb = '     ' THEN
			    BEGIN
			    newpage;
			    sourcepage := sourcepage + 1;
			    sourceline := 0;
			    END
			ELSE            (*HANDLE BLANK LINE*)
			    BEGIN
			    IF (linenb = '-----') AND counting THEN
				sourceline := sourceline + 1;
			    line500 := line500 + 1;
			    linecnt := linecnt + 1;
			    if line500 = 500 then
				begin
				line500 := 0;
				write(tty,'(',linecnt:4,')');
				break(tty);
				end;
			    IF crossing THEN
				BEGIN
				IF reallincnt = maxline THEN
				    header (curprocname);
				reallincnt := reallincnt + 1;
				writeln (crosslist, chr(ht),'  ',linecnt * increment : linnumsize);
				END;
				%13
			    IF renewing THEN
				writeln(newsource);
				\
			    IF maxinc <= linecnt THEN
				newpage;
			    END (*handle blank line*);
			END (*while eoln(oldsource)...*);
		EXIT IF (oldsource↑ <> ' ') OR (eof (oldsource));
		    get(oldsource);
		    END (*loop*);
		bufflen := 0;
		(*READ IN THE LINE*)
		WHILE NOT eoln (oldsource) DO
		    BEGIN
		    bufflen := bufflen + 1;
		    buffer [bufflen] := oldsource↑;
		    get(oldsource);
		    END;
		if bufflen > 300 then
		    begin
		    error(linetoolong);
		    bufflen := 300;
		    end;
		buffer[bufflen+1] := ' '; (*SO WE CAN ALWAYS BE ONE CHAR AHEAD*)
		buffer[bufflen+2] := ' ';
		IF NOT eof (oldsource) THEN
		    BEGIN
		    getlinenr (oldsource,linenb);
		    IF counting THEN
			IF linenb = '-----' THEN
			    sourceline := sourceline + 1
			ELSE
			    BEGIN
			    sourceline := 0;
			    FOR i := 1 TO 5 DO
				sourceline := sourceline * 10 + ord(linenb[i]) - ord('0');
			    END;
		    linecnt := linecnt + 1;
			    line500 := line500 + 1;
			    if line500 = 500 then
				begin
				line500 := 0;
				write(tty,'(',linecnt:4,')');
				break(tty);
				end;
		    readln(oldsource);
		    END;
		bufferptr := 1;
		buffmark := 0;
		END (*READLINE*) ;

	    BEGIN (*READBUFFER*)
	    (*IF READING PAST THE EXTRA BLANK ON THE END, GET A NEW LINE*)
	    IF eoline THEN
		BEGIN
		%34 if not skipping then	\
		writeline (bufferptr);
		ch := ' ';
		IF eof (oldsource) THEN
		    eob := true
		ELSE
		    readline;
		END
	    ELSE
		BEGIN
		ch := buffer [bufferptr];
		bufferptr := bufferptr + 1;
		END;
	    eoline := bufferptr >= bufflen + 2;
	    END (*READBUFFER*) ;

	FUNCTION resword: boolean ;
	    (*DETERMINES IF THE CURRENT IDENTIFIER IS A RESERVED WORD*)
	    VAR
		i,j: integer;
		local: boolean;

	    BEGIN (*RESWORD*)
	    local:= false;
	    i := resnum[sy[1]];
	    WHILE (i < resnum[succ(sy[1])]) AND NOT local DO
		IF reslist[ i ] = sy THEN
		    BEGIN
		    local := true;
		    syty := ressy [i];
		    IF NOT rescase THEN
			FOR j := bufferptr - syleng - 1 TO bufferptr - 2 DO
			    buffer[j] := lower[buffer[j]];
		    END
		ELSE
		    i := i + 1;
	    resword := local;
	    END (*RESWORD*) ;


	PROCEDURE findname(curproc: listptrty);
	    VAR
		lptr: listptrty;        (*ZEIGER AUF DEN VORGAENGER IM BAUM*)
		zptr : lineptrty;       (*ZEIGER AUF DIE VORLETZTE ZEILENNUMMER IN EINER KETTE*)
		found,                  (*SET AFTER IDENTIFIER IS FOUND*)
		right: boolean;         (*MERKVARIABLE FUER DIE VERZWEIGUNG IM BAUM*)
		indexch : char;         (*INDEXVARIABLE FUER DAS FELD DER STARTZEIGER (FIRSTNAME)*)

	    BEGIN (*FINDNAME*)
	    indexch := sy [1];
	    listptr := firstname [indexch];
	    (*SEARCH IN THE TREE FOR THE IDENTIFIER*)
	    found := false;
	    WHILE NOT found AND (listptr <> NIL) DO
		BEGIN
		lptr:= listptr;
		IF sy = listptr↑.name THEN
		    BEGIN
		    found := true;
		    IF (listptr↑.profunflag IN ['P', 'F']) AND (NOT declaring) THEN
			IF locprocstl↑.proclevel + 1 >= listptr↑.procdata↑.proclevel THEN
			    BEGIN
			    new (workcall);
			    workcall↑.whom := listptr↑.procdata;
			    workcall↑.nextcall := NIL;
			    END;
		    zptr := listptr↑.last;
		    IF (zptr↑.linenr <> linecnt+1) OR (zptr↑.pagenr <> pagecnt) THEN
			BEGIN
			new (listptr↑.last);
			WITH listptr↑.last↑ DO
			    BEGIN
			    linenr := linecnt + 1;
			    pagenr := pagecnt;
			    contlink := NIL;
			    IF declaring THEN
				declflag := 'D'
			    ELSE
				declflag := ' ';
			    END;
			zptr↑.contlink := listptr↑.last;
			END
		    ELSE
			zptr↑.declflag := 'M';
		    END
		ELSE
		    IF sy > listptr↑.name THEN
			BEGIN
			listptr:= listptr↑.rlink;
			right:= true;
			END
		    ELSE
			BEGIN
			listptr:= listptr↑.llink;
			right:= false;
			END;
		END;
	    IF NOT found THEN
		BEGIN (*UNKNOWN IDENTIFIER*)
		new (listptr);
		WITH listptr↑ DO
		    BEGIN
		    name := sy;
		    llink := NIL;
		    rlink := NIL;
		    profunflag := ' ';
		    externflag := ' ';
		    procdata := NIL;
		    END;
		IF firstname [indexch] = NIL THEN
		    firstname [indexch] := listptr
		ELSE
		    IF right THEN
			lptr↑.rlink := listptr
		    ELSE
			lptr↑.llink := listptr;
		WITH listptr↑ DO
		    BEGIN
		    new (first);
		    WITH first↑ DO
			BEGIN
			linenr := linecnt + 1;
			pagenr := pagecnt;
			contlink := NIL;
			IF declaring THEN
			    declflag := 'D'
			ELSE
			    declflag := ' ';
			END;
		    last := first ;
		    END;
		END;
	    END (*FINDNAME*) ;

	PROCEDURE insertcall;
	    VAR
		lastcall,
		thiscall: calledty;
		repeated : boolean;     (*SET IF SY IS A PROC-NAME AND IS ALREADY IN THE CALL SEQUENCE*)

	    BEGIN (*INSERTCALL*)
	    IF locprocstl↑.firstcall = NIL THEN
		locprocstl↑.firstcall := workcall
	    ELSE
		BEGIN
		thiscall := locprocstl↑.firstcall;
		repeated := false;
		WHILE (thiscall <> NIL) AND NOT repeated DO
		    IF thiscall↑.whom↑.procname↑.name = workcall↑.whom↑.procname↑.name THEN
			repeated := true
		    ELSE
			BEGIN
			lastcall := thiscall;
			thiscall := thiscall↑.nextcall;
			END;
		IF NOT repeated THEN
		    lastcall↑.nextcall := workcall;
		END;
	    workcall := NIL;
	    END (*INSERTCALL*);


	    (*parenthese*) (*docomment[*) (*options]*) (*skip_e_directory*)

	PROCEDURE parenthese (which: symbol);
	    (*HANDLES THE FORMATTING OF PARENTHESES, EXCEPT THOSE IN VARIANT PARTS OF RECORDS*)
	    VAR
		oldspacesmark : integer;        (*ALTER ZEICHENVORSCHUB BEI FORMATIERUNG VON KLAMMERN*)
	    BEGIN (*PARENTHESE*)
		oldspacesmark := spaces;
		IF NOT oldspaces THEN
		    BEGIN
		    oldspaces := true;
		    lastspaces := spaces;
		    END;
		spaces := lastspaces + bufferptr - buffmark - 2;
		(*SKIP STUFF UNTIL WE SEEM TO BE OUT OF THE EXPRESSION*)
		IF declaring THEN
		    REPEAT
			insymbol;
			CASE syty OF
			    colon: declaring := false;
			    semicolon: declaring := true;
			    END;
		    UNTIL syty IN [which,externsy..whilesy,labelsy..typesy,initprocsy..exitsy,dosy..forwardsy]
		ELSE
		    REPEAT
			insymbol;
		    UNTIL syty IN [which,externsy..whilesy,labelsy..typesy,initprocsy..exitsy,dosy..forwardsy];
		spaces := oldspacesmark;
		oldspaces := true;
		IF syty = which THEN
		    insymbol
		else
		    if which = rparent then
		    error(missgrpar)
		    else
			error(missgrbrack);
	    END (*PARENTHESE*) ;


	PROCEDURE docomment (dellength: integer; firstch: char);

	    var
		lcondcomp: boolean;

	    PROCEDURE options;
		(*processes the options inside a comment that starts with
			a dollar sign.*)
		VAR
		    lch : char;
		    i: integer;
		    lname: packed array[1..5] of char;


		BEGIN (*OPTIONS*)
		REPEAT
		    readbuffer; lch := ch;
		    IF ch <> firstch THEN readbuffer;
		    if lch in ['=','#'] then
			begin
			i := 1;
			lname := '     ';
			while ch in (alphanum + ['_']) do
			    begin
			    if i <= 4 then
				lname[i] := ch;
			    readbuffer;
			    i := i + 1;
			    end;
			if i in [2..5] then
			    if lch = '=' then
				if not programpresent then
				    nameversion := lname
				else
				    error(illversion)
			    else (*lch = '#'*)
				begin
				if lname = nameversion then
 				    begin
				    lcondcomp := true;
				    whichcond := firstch;
				    end
				end
			else (*no name, or too long*)
			    error(illversion);
		        end  (*ch in ['=','*'] *);
		until ch <> ',';
		end (*options*);

	    BEGIN (* DOCOMMENT *)
	    oldspacesmark := spaces;
	    IF oldspaces THEN
		spaces := lastspaces
	    ELSE
		lastspaces := spaces;
	    spaces := spaces + bufferptr - 2;
	    oldspaces := true;
	    lcondcomp := false;
	    if ch = '$' then
		options;
	    incondcomp := incondcomp or lcondcomp;
	    if not lcondcomp then
	    IF dellength = 2 THEN
		REPEAT
		    if not comcase then
			buffer[bufferptr] := lower[buffer[bufferptr]];
		    readbuffer;
		UNTIL (ch = ')') AND (buffer[bufferptr-2] = '*') OR eob
	    ELSE
		REPEAT
		    if not comcase then
			buffer[bufferptr] := lower[buffer[bufferptr]];
		    readbuffer;
		UNTIL (ch = firstch) OR eob;
	 REPEAT
	    readbuffer;
	 UNTIL ch <> ' ';
	 spaces := oldspacesmark;
	 END (*DOCOMMENT*);

	%34

      PROCEDURE skip_e_directory;
	 BEGIN (*SKIP_E_DIRECTORY*)
	 skipping := true;
	    while not eoln(oldsource) do
		readbuffer;
	 skipping := false;
	 END (*SKIP_E_DIRECTORY*);

	\
(*
      PROCEDURE skip_e_directory;
	 BEGIN (*SKIP_E_DIRECTORY*)(*
	 WHILE NOT (oldsource↑ = ';') DO
	    BEGIN
	    IF eoln(oldsource) THEN
	       linecnt := linecnt + 1;
	    get(oldsource);
	    END;
	 get(oldsource);
	 get(oldsource);
	 linecnt :=linecnt + 2;
	 bufferptr := 0;
	 eoline := true;
	 firstpage := true;
	 END (*SKIP_E_DIRECTORY*)(* ;

	\
*)
      (*] INSYMBOL*)

      BEGIN (*INSYMBOL*)
      prevsyty := syty;
      111:
      syleng := 0;
      WHILE (ch IN ['_','(',' ','$','?','@','%','\', %12 '!' \  %34 '"' \ ]) AND NOT eob  DO
	 CASE ch OF
	    '(':
		begin
		readbuffer;
	      IF (ch = '*') THEN
		 docomment (2,'*')
	      ELSE
		begin
		syty := lparent;
		     if variant←level = 0 then
		 parenthese(rparent);
		goto 1;
		end;
		 end;
	    '%':
		begin
		incondcomp := false;
		readbuffer;
		if not anyversion then
		    while ch in digits do
			begin
			if ord(ch) - ord('0') = goodversion then
			    incondcomp := true;
			readbuffer;
			end;
		if incondcomp or anyversion then
		 BEGIN
		 readbuffer;
		 END
	      ELSE
		 docomment (1,'\');
		end;
		%34
	    '"':
		begin
		readbuffer;
	      IF incondcomp and (whichcond = '"') THEN
		  incondcomp := false
		else
	      docomment(1,'"');
		end;
		\
	    OTHERS:
		 readbuffer;
	    END;
      CASE ch OF
	    'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I',
	    'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q',
	    'R', 'S', 'T', 'U', 'V', 'W', 'X', 'Y',
	    'Z':
	      BEGIN
	      syleng := 0;
	      sy := '          ';
	      REPEAT
		  syleng := syleng + 1;
		  IF syleng <= 10 THEN
		      sy [syleng] := ch;
		  readbuffer;
	      UNTIL NOT (ch IN (alphanum + ['←']));
		%34
		if firstpage and (sy = 'comment   ') then
		    begin
		    skip_e_directory;
		    goto 111;
		    end
		else
		\
	      IF NOT resword THEN
		  BEGIN
		  syty := ident ;
		  findname(curproc);
		  IF NOT nonrcase THEN
		      FOR i := bufferptr - syleng - 1 TO bufferptr - 2 DO
			  buffer[i] := lower[buffer[i]];
		  END
	      END;
	    '0', '1', '2', '3', '4', '5', '6', '7', '8',
	    '9':
	      BEGIN
	      REPEAT
		  syleng := syleng + 1;
		  readbuffer;
	      UNTIL NOT (ch IN digits);
	      syty := intconst;
	      IF ch = 'B' THEN
		  readbuffer
	      ELSE
		  BEGIN
		  IF ch = '.' THEN
		      BEGIN
		      REPEAT
			  readbuffer
		      UNTIL NOT (ch IN digits);
		      syty := othersy; syleng := 0; (*REALS CAN'T BE LABELS*)
		      END;
		  IF ch = 'E' THEN
		      BEGIN
		      readbuffer;
		      IF ch IN ['+','-'] THEN
			  readbuffer;
		      WHILE ch IN digits DO
			  readbuffer;
		      syty := othersy; syleng := 0; (*REALS CAN'T BE LABELS*)
		      END;
		  END;
	      END;
	    '''':
	       BEGIN
	       syty := strgconst;
	       REPEAT
		   readbuffer;
	       UNTIL (ch = '''') OR eob OR eoline;
	       IF ch <> '''' THEN
		   error(missgquote);
	       readbuffer;
	       END;
	    %12  '"':	\
	    %34  '!':	\
	      BEGIN
	      REPEAT
		  readbuffer
	      UNTIL NOT (ch IN  (digits + ['A'..'F']));
	      syty := intconst;
	      END;
	    ' ': syty := eobsy;   (*END OF FILE*)
	    ':': BEGIN
		 readbuffer;
		 if ch = '=' then
		     begin
		     workcall := NIL;
		     syty := othersy;
		     readbuffer;
		     END
		 else
		     syty := delsy[':'];
		 end;
	    '\':
		begin
		readbuffer;
	      IF incondcomp and (whichcond = '\') THEN
		  BEGIN
		  incondcomp := false;
		  GOTO 111;
		  END
		else
		    syty := othersy;
		  end;
	    '*':
		begin
		readbuffer;
	      IF incondcomp and (whichcond = '*') THEN
		     if ch = ')' then
			begin
		  incondcomp := false;
		  readbuffer;
		  GOTO 111;
			end
		     else
			syty := othersy;
		end;
	    '[':
		begin
		syty := lbracket; readbuffer; parenthese(rbracket);
		end;
	    OTHERS:
		 BEGIN
		 syty := delsy [ch];
		 readbuffer;
		 END
	    END (*case ch of*);
	1:
	IF workcall <> NIL THEN
	    insertcall;
	END (*INSYMBOL*) ;
	(*PARSING OF DECLARATIONS:*) (*RECDEF[*) (*CASEDEF*) (*PARENTHESE*) (*]*)

    PROCEDURE recdef;
	VAR
	    oldspacesmark  : integer;         (*ALTER ZEICHENVORSCHUB BEI FORMATIERUNG VON RECORDS*)


	PROCEDURE casedef;
	    VAR
		oldspacesmark  : integer;       (*ALTER ZEICHENVORSCHUB BEI FORMATIERUNG VON VARIANT PARTS*)


	    PROCEDURE parenthese;
		(*HANDLES THE FORMATTING OF PARENTHESES INSIDE VARIANT PARTS*)
		VAR
		    oldspacesmark : integer;      (*SAVED VALUE OF 'SPACES'*)
		BEGIN (*PARENTHESE*)
		oldspacesmark := spaces;
		IF NOT oldspaces THEN
		    BEGIN
		    oldspaces := true;
		    lastspaces := spaces;
		    END;
		spaces := spaces + bufferptr - 2;
		declaring := true;
		insymbol;
		REPEAT
		    CASE syty OF
			casesy  :
			       casedef;
			recordsy :
				recdef;
			semicolon, lparent:
					 BEGIN
					 declaring := true;
					 insymbol;
					 END;
			eqlsy, colon:
				   BEGIN
				   declaring := false;
				   insymbol;
				   END;
			OTHERS :
			      insymbol;
			END;
		    (*UNTIL WE APPARENTLY LEAVE THE DECLARATION*)
		UNTIL syty IN [strgconst..whilesy,rparent,labelsy..exitsy,dosy..beginsy,
			       loopsy..ifsy,forwardsy];
		spaces := oldspacesmark;
		oldspaces := true;
		IF syty = rparent THEN
		    BEGIN
		    declaring := true;
		    insymbol;
		    END
		ELSE
		    error(missgrpar);
		END (*PARENTHESE*) ;

	    BEGIN (*CASEDEF*)
	    variant←level := variant←level+1;
	    oldspacesmark := spaces;
	    IF NOT oldspaces THEN
		BEGIN
		oldspaces := true;
		lastspaces := spaces;
		END;
	    spaces := bufferptr - buffmark + lastspaces - syleng + 3;
	    declaring := true;
	    insymbol;
	    declaring := false;
	    REPEAT
		IF syty = lparent THEN
		    parenthese
		ELSE
		    insymbol
	    UNTIL syty IN [untilsy..exitsy,labelsy..endsy,rparent,dosy..beginsy];
	    spaces := oldspacesmark;
	    variant←level := variant←level-1;
	    END (*CASEDEF*) ;

	BEGIN (*RECDEF*)
	oldspacesmark := spaces;
	oldspaces := true;
	lastspaces := spaces;
	spaces := bufferptr - buffmark + spaces - syleng - 2 + feed;
	declaring := true;
	insymbol;
	REPEAT
	    CASE syty OF
		casesy   : casedef;
		recordsy : recdef;
		semicolon, lparent:
				 BEGIN
				 declaring := true;
				 insymbol;
				 END;
		eqlsy, colon:
			   BEGIN
			   declaring := false;
			   insymbol;
			   END;
			endsy:;
		OTHERS   : insymbol
		END;
	UNTIL syty IN [untilsy..exitsy,labelsy..endsy,dosy..beginsy];
	oldspaces := true;
	lastspaces := spaces - feed;
	spaces := oldspacesmark;
	IF syty = endsy THEN
	    BEGIN
	    declaring := true;
	    insymbol;
	    END
	ELSE
	    error(missgend);
	END (*RECDEF*) ;
	(*PARSING OF STATEMENTS:*) (*STATEMENT[*) (*AND ITS PARTS*) (*]*)


    PROCEDURE statement;
	VAR
	    oldspacesmark,           (*SPACES AT ENTRY OF THIS PROCEDURE*)
	    curblocknr : integer;     (*CURRENT BLOCKNUMBER*)


	PROCEDURE endedstatseq(endsym: symbol;  letter: char);
	    BEGIN
	    statement;
	    WHILE syty = semicolon DO
		BEGIN
		insymbol;
		statement;
		END;
	    WHILE NOT (syty IN [endsym,eobsy,proceduresy,functionsy]) DO
		BEGIN
		error(missgend);
		IF NOT (syty IN begsym) THEN
		    insymbol;
		statement;
		WHILE syty = semicolon DO
		    BEGIN
		    insymbol;
		    statement;
		    END;
		END;
	    IF forcing THEN
		writeline(bufferptr-syleng);
	    emarktext := letter;
	    emarknr := curblocknr;
	    oldspaces := true;
	    IF (endsym = endsy) THEN
		begin
		IF indentbegin = 0 THEN
		    lastspaces := max(0,spaces-begexd)
		ELSE
		    lastspaces := max(0,spaces-indentbegin);
		if syty <> endsy then
		    error(missgend)
		end
	    ELSE
		begin
		lastspaces := max(0,spaces - feed);
	    IF syty <> endsym THEN
		error(missguntil);
		end;
	    END (*ENDEDSTATSEQ*);


	PROCEDURE compstat;
	    BEGIN (*COMPSTAT*)
	    IF indentbegin = 0 THEN
		BEGIN
		IF NOT oldspaces THEN
		    BEGIN
		    oldspaces := true;
		    lastspaces := max (0,spaces-begexd)
		    END;
		END
	    ELSE
		IF NOT oldspaces THEN
		    BEGIN
		    oldspaces := true;
		    lastspaces := max (0,spaces - indentbegin);
		    END;
	    bmarktext := 'B';
	    marksyty := prevsyty;
	    insymbol;
	    IF forcing THEN
		begin
		if marksyty = othersy then
		    elsehere := true;
		writeline(bufferptr-syleng);
		elsehere := false;
		end;
	    endedstatseq(endsy, 'E');
	    IF syty = endsy THEN
		BEGIN
		insymbol ;
		writeline(bufferptr-syleng);
		END;
	    END (*COMPSTAT*) ;


	PROCEDURE casestat;
	    VAR
		oldspacesmark : integer;        (*SAVED VALUE OF 'SPACES'*)

	    BEGIN (*CASESTAT*)
	    bmarktext := 'C';
	    IF NOT oldspaces THEN
		BEGIN
		oldspaces := true;
		lastspaces := max (0,spaces-feed);
		END;
	    insymbol;
	    statement;
	    IF syty = ofsy THEN
		writeline (bufferptr)
	    ELSE
		error (missgof);
	    LOOP
		REPEAT
		    REPEAT
			insymbol;
		    UNTIL syty IN [colon, functionsy .. eobsy];
		    IF syty = colon THEN
			BEGIN
			oldspacesmark := spaces;
			lastspaces := spaces;
			%34 spaces := spaces + feed;	\
			%12 spaces := bufferptr - buffmark + spaces - 4;	\
			oldspaces := true;
			thendo := true;
			insymbol;
			statement;
			IF syty = semicolon THEN
			    insymbol;
			spaces := oldspacesmark;
			END;
		UNTIL syty IN endsym;
	    EXIT IF syty IN [endsy,eobsy,proceduresy,functionsy];
		error (missgend);
		END;
	    writeline(bufferptr-syleng);
	    emarktext := 'E';
	    emarknr := curblocknr;
	    IF syty = endsy THEN
		BEGIN
		insymbol ;
		writeline(bufferptr-syleng);
		END
	    ELSE
		error (missgend);
	    END (*CASESTAT*) ;


	PROCEDURE loopstat;
	    BEGIN (*LOOPSTAT*)
	    bmarktext := 'L';
	    IF NOT oldspaces THEN
		BEGIN
		oldspaces := true;
		lastspaces := max (0,spaces - feed);
		END;
	    marksyty := prevsyty;
	    insymbol;
	    if not (marksyty in openblocksym) then
		elsehere := true;
	    writeline(bufferptr-syleng);
	    elsehere := false;
	    statement;
	    WHILE syty = semicolon DO
		BEGIN
		insymbol;
		statement;
		END;
	    IF syty = exitsy THEN
		BEGIN
		writeline(bufferptr-syleng);
		oldspaces := true;
		lastspaces := spaces-feed;
		emarktext := 'X';
		emarknr := curblocknr;
		insymbol; insymbol;
		prevsyty := exitsy;
		END
	    ELSE
		error(missgexit);
	    endedstatseq(endsy, 'E');
	    IF syty = endsy THEN
		BEGIN
		insymbol ;
		writeline(bufferptr-syleng);
		END;
	    END (*LOOPSTAT*) ;


	PROCEDURE ifstat;
	    VAR
		oldspacesmark: integer;

	    BEGIN  (*IFSTAT*)
	    marksyty := prevsyty;
	    oldspacesmark := spaces;
	    bmarktext := 'I';
	    IF NOT oldspaces THEN
		BEGIN
		oldspaces := true;
		lastspaces := max (0,spaces - feed);
		END;
	    (*MAKE 'THEN' AND 'ELSE' LINE UP WITH 'IF' UNLESS ON SAME LINE*)
	    spaces := lastspaces + bufferptr - buffmark + feed - 4;
	    insymbol;
	    statement; (*WILL EAT THE EXPRESSION AND STOP ON A KEYWORD*)
	    IF syty = thensy THEN
		BEGIN
		IF NOT oldspaces THEN
		    BEGIN
		    oldspaces := true;
		    lastspaces := max (0,spaces-feed);
		    END;
		emarktext := 'T';
		emarknr := curblocknr;
		IF forcing THEN
		    begin
		    if not (marksyty in openblocksym) then
		    elsehere := true;
		    writeline(bufferptr);
		    elsehere :=false;
		    end
		ELSE
		    thendo := true;
		(*SUPPRESS FURTHER INDENTATION FROM A 'DO'*)
		insymbol;
		statement;
		END
	    ELSE
		error (missgthen);
	    IF syty = elsesy THEN	(*parse the else part*)
		BEGIN
		writeline(bufferptr-syleng);
		emarktext := 'S';
		emarknr := curblocknr;
		IF NOT oldspaces THEN
		    BEGIN
		    oldspaces := true;
		    lastspaces := max (0,spaces-feed);
		    END;
		IF forcing THEN
		    begin
		    elsehere := true;
		    writeline(bufferptr);
		    elsehere := false;
		    end
		ELSE
		    thendo := true;
		insymbol;
		statement;
		END;
	    oldspaces := true; (*PRESERVE INDENTATION OF STATEMENT*)
	    writeline(bufferptr-syleng);
	    spaces := oldspacesmark;
	    END (*IFSTAT*) ;


	PROCEDURE labelstat;
	    BEGIN (*LABELSTAT*)
	    lastspaces := level * feed;
	    oldspaces := true;
	    insymbol;
	    elsehere := true;
	    writeline(bufferptr-syleng);
	    elsehere := false;
	    END (*LABELSTAT*) ;


	PROCEDURE repeatstat;
	    BEGIN
	    bmarktext := 'R';
	    IF NOT oldspaces THEN
		BEGIN
		oldspaces := true;
		lastspaces := max (0,spaces - feed);
		END;
		marksyty :=prevsyty;
	    insymbol;
		if not (marksyty in openblocksym) then
		    elsehere := true;
	    endedstatseq(untilsy, 'U');
	    IF syty = untilsy THEN
		BEGIN
		insymbol;
		statement;
		writeline(bufferptr-syleng);
		END;
	    END (*REPEATSTAT*) ;

	BEGIN (*STATEMENT*)
	oldspacesmark := spaces; (*SAVE THE INCOMING VALUE OF SPACES TO BE ABLE TO RESTORE  IT*)
	IF syty = intconst THEN
	    BEGIN
	    insymbol;
	    IF syty = colon THEN
		labelstat;
	    END;
	IF syty IN begsym THEN
	    BEGIN
	    blocknr := (blocknr + 1) MOD 1000;
	    curblocknr := blocknr;
	    bmarknr := curblocknr;
	    IF NOT thendo THEN
		BEGIN
		writeline(bufferptr-syleng);
		elsehere := false;
		IF (syty <> beginsy) THEN
		    spaces := spaces + feed
		ELSE
		    spaces:=spaces + indentbegin;
		END;
	    CASE syty OF
		beginsy : compstat;
		loopsy  : loopstat;
		casesy  : casestat;
		ifsy    : ifstat;
		repeatsy: repeatstat
		END;
	    END
	ELSE
	    BEGIN
	    IF forcing THEN
		IF syty IN [forsy,whilesy] THEN
		    writeline(bufferptr-syleng);
	    IF syty = gotosy THEN
		gotoinline:=true;
	    WHILE NOT (syty IN [semicolon,functionsy..recordsy]) DO
		insymbol;
	    IF syty = dosy THEN
		BEGIN
		IF NOT thendo THEN
		    BEGIN
		    oldspaces := true;
		    lastspaces := spaces;
		    spaces := spaces + feed;
		    IF NOT forcing THEN
			thendo := true;
		    END;
		insymbol;
		statement;
		writeline(bufferptr-syleng);
		END;
	    END;
	spaces := oldspacesmark;
	END (*STATEMENT*) ;

	(*]BLOCK*)

    BEGIN (*BLOCK*)
    stmtpart := false;
    declaring := true;
    REPEAT
	insymbol;
    UNTIL syty IN relevantsym;
    level := level + 1;
    curproc := listptr;
    spaces := level * feed;
    (*HANDLE NESTING LIST*)
    locprocstl := procstrucf;
    WITH procstrucdata, item, procname↑ DO
	IF exists THEN
	    BEGIN
	    IF procdata <> NIL THEN
		BEGIN
		IF externflag = 'F' THEN
		    procdata := NIL
		ELSE
		    IF externflag = ' ' THEN
			externflag := 'D';
		locprocstl := procdata;
		END;
	    IF procdata = NIL THEN
		BEGIN
		IF (syty IN [forwardsy,externsy]) THEN
		    IF syty = externsy THEN
			externflag := 'E'
		    ELSE
			externflag := 'F';
		new(procstrucl↑.nextproc);
		procstrucl := procstrucl↑.nextproc;
		procdata := procstrucl;
		procstrucl↑ := item;
		locprocstl := procstrucl;
		END;
	    procstrucdata.exists := false
	    END;
    REPEAT
	fwddecl := false;
	WHILE syty IN decsym DO			(*declarations: labels, types, vars*)
	    BEGIN
	    writeline(bufferptr-syleng);
	    oldspaces := true;
	    lastspaces := max(0,spaces-feed);
	    IF syty = programsy THEN
		BEGIN
		programpresent := true;
		insymbol;
		prog←name := sy;
		procstrucf↑.procname := listptr;
		listptr↑.procdata := procstrucf;
		listptr↑.profunflag := 'M';
		writeln(tty);
		write(tty,version:verlength,': ',old←name:6,' [ ',prog←name,' ] PAGE');
		FOR i := 1 TO pagecnt DO
		    write (tty, i:3,'..');
		break(tty);
		declaring := false;
		END
	    ELSE	(*syty <> programsy*)
		BEGIN
		declaring := true;
		IF forcing THEN
		    writeline(bufferptr);
		END;
	    REPEAT
		insymbol;
		CASE syty OF
		    semicolon, lparent : declaring := true;
		    eqlsy, colon : declaring := false;
		    recordsy: recdef;
		    END;
	    UNTIL syty IN relevantsym;
	    END;
	declaring := false;
	WHILE syty IN prosym DO			(*procedure and function declarations*)
	    BEGIN
	    writeline(bufferptr-syleng);
	    oldspaces := true;
	    lastspaces := max(0,spaces-feed);
	    lastprocname := curprocname;
	    IF syty <> initprocsy THEN
		BEGIN
		itisaproc := syty = proceduresy;
		declaring := true;
		insymbol;
		curprocname := listptr↑.name;
		IF itisaproc THEN
		    listptr↑.profunflag := 'P'
		ELSE
		    listptr↑.profunflag := 'F';
		WITH procstrucdata, item DO
		    BEGIN
		    exists := true;
		    procname := listptr;
		    nextproc := NIL;
		    linenr := linecnt+1;
		    pagenr := pagecnt;
		    proclevel := level;
		    printed := false;
		    firstcall := NIL;
		    END;
		END
	    ELSE
		curprocname := 'INITPROCED';
	    block;
	    curprocname := lastprocname;
	    declaring := false;
	    stmtpart := false;
	    IF syty = semicolon THEN
		insymbol;
	    END (*while syty in prosym*)
	(*FORWARD AND EXTERNAL DECLARATIONS MAY COME BEFORE 'VAR', ETC.*)
    UNTIL NOT fwddecl;
    IF forcing THEN
	writeline(bufferptr-syleng);
    level := level - 1;
    spaces := level * feed;
    IF NOT (syty IN [beginsy,forwardsy,externsy,eobsy,langsy]) THEN
	BEGIN
	IF (level = 0) AND (syty = point) THEN
	    nobody := true
	ELSE
	    error (begerrinblkstr);
	WHILE NOT (syty IN [beginsy,forwardsy,externsy,eobsy,langsy,point]) DO
	    insymbol
	END;
    IF syty = beginsy THEN
	BEGIN
	countline := sourceline;  (*to get the count in the line of the begin*)
	countpage := sourcepage;
	declaring := false;
	stmtpart := true;	  (*to prevent bars in declarations*)
	locprocstl↑.begline := linecnt + 1;
	locprocstl↑.begpage := pagecnt;
	statement;
	locprocstl↑.endline := linecnt + 1;
	locprocstl↑.endpage := pagecnt;
	END
    ELSE
	IF NOT nobody THEN
	    BEGIN
	    fwddecl := true;
	    insymbol;
	    END;
    IF level = 0 THEN
	if programpresent then
	BEGIN
	IF nobody THEN
	    BEGIN
	    error (missgmain);
	    errcount := errcount - 1;
	    END;
	IF syty <> point THEN
	    BEGIN
	    error(missgpoint);
	    REPEAT (*SKIP TEXT UNTIL END OF FILE OR END OF PROGRAM HIT*)
		REPEAT
		    insymbol
		UNTIL (syty = endsy) OR (syty = eobsy);
		IF syty = endsy THEN
		    insymbol;
	    UNTIL (syty = point) OR (syty = eobsy);
	    END;
	writeline(bufflen+2);
	writeln(tty);
	writeln (tty,errcount:4,' ERROR(S) DETECTED');   break(tty);
	END (*if level = 0*);
    END (*BLOCK*) ;

    (*PRINT←XREF←LIST[*) (*CHECKPAGE*) (*WRITEPROCNAME*) (*WRITELINENR*) (*DUMPCALL*) (*]*)

PROCEDURE print←xref←list;
    VAR
	pred : listptrty;
	indexch : char;         (*LAUFVARIABLE FUER DAS FELD 'FIRSTNAME' ZUM AUSDRUCKEN*)
	listpgnr : boolean;     (*TRUE IF THE SOURCE CONTAINS A PAGE MARK*)
	itemlen: integer;        (*LENGTH OF A PRINTED LINENUMBER, 9 OR 12*)
	thiscall : calledty;
	oldcrossing: boolean;


    PROCEDURE checkpage(heading: boolean);
	BEGIN
	IF reallincnt = maxline THEN
	    BEGIN
	    IF heading THEN
		header (listptr↑.name)
	    ELSE
		header (blanks);
	    END;
	reallincnt:=reallincnt+1;
	END(*CHECKPAGE*);

    PROCEDURE writeprocname (procstrucl: procstructy; depth: integer; mark: char; numbering: boolean);
	BEGIN (*WRITEPROCNAME*)
	writeln(crosslist);
	checkpage(false);
	WITH procstrucl↑, procname↑ DO
	    BEGIN
	    IF numbering THEN
		write (crosslist, linecnt * increment:linnumsize+1, ' ');
	    IF depth > 2 THEN
		write (crosslist, '. ',dots:depth-1)
	    ELSE
		write (crosslist, '.':depth+1);
	    write  (crosslist, name : 10, ' (', profunflag, ')',
		    mark:2, externflag:2, chr(ht), linenr * increment : 8);
	    IF listpgnr OR (pagenr > 1) THEN
		write(crosslist, '/',pagenr : 2);
	    IF (mark = ' ') AND NOT (externflag IN ['E', 'F']) THEN
		BEGIN
		write (crosslist, begline * increment: linnumsize + 3);
		IF listpgnr THEN
		    write (crosslist, '/', begpage: 2);
		write (crosslist, endline * increment: linnumsize + 3);
		IF listpgnr THEN
		    write (crosslist, '/', endpage:2);
		END
	    ELSE
		IF externflag = 'F' THEN
		    externflag := ' ';
	    END;
	END (*WRITEPROCNAME*);

    PROCEDURE writelinenr (spaces : integer);

	VAR
	    link : lineptrty; (*ZEIGER ZUM DURCHHANGELN DURCH DIE VERKETTUNG DER ZEILENNUMMERN*)
	    maxcnt,             (*MAXIMUM ALLOWABLE VALUE OF COUNT*)
	    count : integer;  (*ZAEHLT DIE GEDRUCKTEN ZEILENNUMMERN PRO ZEILE*)
	BEGIN (*WRITELINENR*)
	count := 0;
	maxcnt := (maxcrossch + 1 - spaces) DIV itemlen; (*ITEMS ARE ITEMLEN CHARS EACH*)
	link := listptr↑.first;
	REPEAT
	    IF count = maxcnt THEN
		BEGIN
		writeln(crosslist);
		checkpage(true);
		write (crosslist, ' ' : spaces);
		count := 0;
		END;
	    count := count + 1;
	    WITH link↑ DO
		BEGIN
		write (crosslist, linenr * increment : linnumsize + 1);
		IF listpgnr THEN
		    write(crosslist, '/',pagenr : 2);
		write (crosslist,declflag);
		link := contlink;
		END;
	UNTIL link = NIL;
	END (*WRITELINENR*) ;

    PROCEDURE dumpcall (thisproc: procstructy; depth: integer);
	VAR
	    thiscall: calledty;

	BEGIN (*DUMPCALL*)
	linecnt := linecnt + 1;
	WITH thisproc↑ DO
	    IF printed THEN
		writeprocname (thisproc, depth,'*', true)
	    ELSE
		BEGIN
		writeprocname (thisproc, depth, ' ', true);
		printed := true;
		linenr := linecnt;
		pagenr := pagecnt;
		thiscall := firstcall;
		WHILE thiscall <> NIL DO
		    BEGIN
		    dumpcall (thiscall↑.whom, depth + feed);
		    thiscall := thiscall↑.nextcall;
		    END;
		END;
	END (*DUMPCALL*);

    BEGIN (*PRINT←XREF←LIST*)
    oldcrossing := crossing;
    crossing := true;
    listpgnr := pagecnt > 1;
    itemlen := linnumsize + 2;
    IF listpgnr THEN
	itemlen := itemlen + 3;
    WITH firstname ['M']↑ DO  (*DELETE 'MAIN'*)
	IF rlink = NIL THEN
	    firstname ['M'] := llink
	ELSE
	    BEGIN
	    listptr := rlink;
	    WHILE listptr↑.llink <> NIL DO
		listptr := listptr↑.llink;
	    listptr↑.llink := llink;
	    firstname ['M'] := rlink;
	    END;
    indexch := 'A';
    WHILE (indexch < 'Z') AND (firstname [indexch] = NIL) DO
	indexch := succ (indexch);
    IF firstname [indexch] <> NIL THEN
	BEGIN
	IF refing THEN
	    BEGIN
	    pagecnt := pagecnt + 1;
	    pagecnt2 := 0;
	    header (blanks);
	    writeln (crosslist, 'CROSS REFERENCE LISTING OF IDENTIFIERS');
	    writeln (crosslist, '**************************************');
	    write(tty,'CROSS REFERENCE..'); break;
	    reallincnt:= reallincnt + 3;
	    FOR indexch := indexch TO 'Z' DO
		WHILE firstname [indexch] <> NIL DO
		    BEGIN
		    listptr := firstname [indexch];
		    WHILE listptr↑.llink <> NIL DO
			BEGIN
			pred := listptr;
			listptr := listptr↑.llink;
			END;
		    IF listptr = firstname [indexch] THEN
			firstname [indexch] := listptr↑.rlink
		    ELSE
			pred↑.llink := listptr↑.rlink;
		    writeln(crosslist);
		    checkpage(true);
		    write (crosslist, listptr↑.profunflag, listptr↑.name : 11);
		    writelinenr (12);
		    END;
	    END;

	IF procstrucl <> procstrucf THEN
	    BEGIN
	    IF decnesting THEN
		BEGIN
		pagecnt := pagecnt + 1;
		pagecnt2 := 0;
		writeln (crosslist);
		header ('*DECLARAT*');
		writeln (crosslist, 'NESTING OF PROCEDURE-FUNCTION DECLARATION');
		writeln (crosslist, '*****************************************');
		writeln (crosslist, 'NAME, P/F, HEADERLINE, BEGINLINE, ENDLINE');
		write(tty,' PROCEDURE DECLARATIONS..'); break;
		reallincnt:= reallincnt + 4;
		procstrucl := procstrucf;
		REPEAT
		    writeprocname (procstrucl, procstrucl↑.proclevel * 4, ' ', false);
		    procstrucl := procstrucl↑.nextproc;
		UNTIL procstrucl = NIL;
		END;
	    IF callnesting THEN
		BEGIN
		pagecnt := pagecnt + 1;
		pagecnt2 := 0;
		writeln (crosslist);
		header ('* CALLS * ');
		writeln (crosslist, 'NESTING OF PROCEDURE-FUNCTION CALLS');
		writeln (crosslist, '***********************************');
		writeln (crosslist, 'NAME, P/F, HEADERLINE, BEGINLINE, ENDLINE');
		write(tty,' PROCEDURE CALLS..'); break;
		reallincnt := reallincnt + 4;
		linecnt := 0;
		procstrucl := procstrucf;
		WHILE procstrucl <> NIL DO
		    BEGIN
		    IF NOT procstrucl↑.printed THEN
			dumpcall (procstrucl, 0);
		    procstrucl := procstrucl↑.nextproc;
		    END;
		END;
	    END;
	END;
    crossing := oldcrossing;
    END (*PRINT←XREF←LIST*) ;

    (*MAIN PROGRAM*)

BEGIN
settime;
get←directives;
initialize;

(*FIND MAX POSSIBLE LINE NUMBER WITH THIS INCREMENT*)
%12
maxinc := (99999 DIV increment);
IF maxinc > 4000 THEN
    maxinc := 4000;
\
%34
maxinc := (1000 div increment);
\

LOOP
    block;
EXIT IF NOT programpresent OR (syty = eobsy);
    IF counting THEN
	BEGIN
	writeln(tty);
	writeln(tty,'MAXIMUM COUNT: ',maxcounttimes,' AT LINE ',maxcountline*increment:5,'/',maxcountpage:2);
	IF crossing THEN
	    BEGIN
	    writeln(crosslist);
	    writeln(crosslist,'MAXIMUM COUNT: ',maxcounttimes,' AT LINE ',maxcountline*increment:5,'/',maxcountpage:2);
	    END;
	END;
    IF refing OR decnesting OR callnesting THEN
	print←xref←list;
    dispose(heapmark);    (*RELEASE THE ENTIRE HEAP*)
    reinitialize;
    END;

if counting then
    rewrite(countfile);

timereport(ttyoutput, '          ');

getnextcall (link←name, link←device);
IF link←name <> '         ' THEN
    call (link←name, link←device);
END (*PCROSS*).